home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Environments / Clean 1.2.4 / IO Examples / Life / Life.icl < prev    next >
Text File  |  1997-04-28  |  8KB  |  231 lines
  1. implementation module Life
  2.  
  3. import StdEnv, deltaPicture
  4.  
  5. ::    Generation    :==    [[LifeCell]]
  6. ::    CellSize    :==    Int
  7. ::    ClickPoint    :== (!Int,!Int)
  8. ::    LifeCell
  9.     =    {    x    :: !Int
  10.         ,    y    :: !Int
  11.         ,    age    :: !Int
  12.         }
  13.  
  14. Colours :: {!Colour}
  15. Colours =: {RedColour,MagentaColour,GreenColour,YellowColour,CyanColour,BlueColour}
  16.  
  17. ageToColour :: !Int -> Colour
  18. ageToColour age
  19. |    age<=0        = Colours.[0]
  20. |    age>=5        = Colours.[5]
  21. |    otherwise    = Colours.[age]
  22.  
  23. MakeGeneration :: Generation
  24. MakeGeneration = []
  25.  
  26. MakeLifeCell :: !ClickPoint !CellSize -> LifeCell
  27. MakeLifeCell (x,y) size
  28. =    {x=ClickPointToCell x size,y=ClickPointToCell y size,age=0}
  29. where
  30.     ClickPointToCell :: !Int !Int -> Int
  31.     ClickPointToCell x size
  32.     |    x<0            = x/size-1
  33.     |    otherwise    = x/size
  34.  
  35. NewLifeCell :: !Int !Int -> LifeCell
  36. NewLifeCell x y
  37. =    {x=x,y=y,age=0}
  38.  
  39.  
  40. //    Rendering of LifeCells.
  41.  
  42. DrawCells :: !(LifeCell -> DrawFunction) !Generation -> [DrawFunction]
  43. DrawCells f gen = map f (flatten gen)
  44.  
  45. DrawCell :: !CellSize !LifeCell !Picture -> Picture
  46. DrawCell size {x,y,age} pict
  47. #    pict    = SetPenColour (ageToColour age)                pict
  48.     pict    = FillRectangle ((px,py),(px+size,py+size))        pict
  49. |    size<=2    = pict
  50. #    pict    = SetPenColour BlackColour                        pict
  51.     pict    = DrawRectangle ((px-1,py-1),(px+size,py+size))    pict
  52. =    pict
  53. where
  54.     px        = x*size
  55.     py        = y*size
  56.  
  57. EraseCell :: !CellSize !LifeCell !Picture -> Picture
  58. EraseCell size {x,y} pict
  59. =    EraseRectangle ((px,py),(px+size,py+size)) pict
  60. where
  61.     px        = x*size
  62.     py        = y*size
  63.  
  64.  
  65. /*    Insert a LifeCell to a Generation. 
  66.     In a Generation LifeCells are ordered by increasing x-coordinate first, and by increasing y-coordinate second.
  67. */
  68. InsertCell::!LifeCell !Generation -> Generation
  69. InsertCell c1=:{x=x1} gen=:[cs=:[{x=x2,y=y2}:x2ys] : cs_xs]
  70. |    x2<x1            = [cs                : InsertCell c1 cs_xs]
  71. |    x2==x1            = [InsertCelly c1 cs: cs_xs]
  72. |    otherwise        = [[c1],cs            : cs_xs]
  73. where
  74.     InsertCelly :: !LifeCell ![LifeCell] -> [LifeCell]
  75.     InsertCelly c1=:{y=y1} [c2=:{x=x2,y=y2}:x2ys]
  76.     |    y2<y1        = [c2    : InsertCelly c1 x2ys]
  77.     |    y2==y1        = [c1    : x2ys]
  78.     |    otherwise    = [c1,c2: x2ys]
  79.     InsertCelly c1 _= [c1]
  80. InsertCell c1 []
  81. =    [[c1]]
  82.  
  83. /*    Remove a LifeCell from a Generation.
  84. */
  85. RemoveCell::!LifeCell !Generation -> Generation
  86. RemoveCell c1=:{x=x1,y=y1} gen=:[cs=:[{x=x2,y=y2}:x2ys]:cs_xs]
  87. |    x2<x1            = [cs:RemoveCell c1 cs_xs]
  88. |    x2>x1            = gen
  89. #    cs                = RemoveCelly c1 cs
  90. |    isEmpty cs        = cs_xs
  91. |    otherwise        = [cs : cs_xs]
  92. where
  93.     RemoveCelly :: !LifeCell ![LifeCell] -> [LifeCell]
  94.     RemoveCelly c1=:{y=y1} cs=:[c2=:{x=x2,y=y2}:x2ys]
  95.     |    y2<y1        = [c2 : RemoveCelly c1 x2ys]
  96.     |    y2==y1        = x2ys
  97.     |    otherwise    = cs
  98.     RemoveCelly _ _    = []
  99. RemoveCell c [[]:cs_xs]
  100. =    RemoveCell c cs_xs
  101. RemoveCell c _
  102. =    []
  103.  
  104. /*    Calculate the new Generation (first tuple result) and the Generation of LifeCells that die (second tuple result).
  105. */
  106. LifeGame::!Generation -> (!Generation,!Generation)
  107. LifeGame gen
  108. #    (next,_,die)    = NextGen gen gen
  109.     next            = CelebrateSurvival next gen
  110. =    (next,die)
  111. where
  112.     NextGen::!Generation Generation -> (!Generation,Generation,!Generation)
  113.     NextGen [[c=:{x,y}:cs_x]:cs_xs] gen
  114.     |    Neighbours34 (Neighbours c gen)    = (InsertCell c gennext1,new,diednext)
  115.     |    otherwise                        = (gennext1,new,InsertCell c diednext)
  116.     where
  117.         (gennext,newbornsnext,diednext)    = NextGen [cs_x:cs_xs] gen1
  118.         (gennext1,new)                    = NewBorns c newbornsnext gennext gen
  119.         gen1                            = ShiftGeneration [cs_x:cs_xs] gen
  120.         
  121.         Neighbours34 [_,_,_]    =  True
  122.         Neighbours34 [_,_,_,_]     =  True
  123.         Neighbours34 _            =  False
  124.         
  125.         NewBorns::!LifeCell Generation Generation Generation -> (!Generation,Generation)
  126.         NewBorns c newbornsnext gennext gen
  127.         =    NewBorns1 (NewBornNeighbours c gen) newbornsnext gennext gen
  128.         where
  129.             NewBorns1 [c=:{x=x1,y=y1}:cs] newbornsnext gennext gen
  130.             |    Neighbours3 (Neighbours c gen)    = (InsertCell c gennext1,InsertCell c newbornsnext1)
  131.             |    otherwise                        = next_genANDnewborns
  132.             where
  133.                 (gennext1,newbornsnext1)        = next_genANDnewborns
  134.                 next_genANDnewborns                 = NewBorns1 cs newbornsnext gennext gen
  135.                 
  136.                 Neighbours3::![LifeCell] -> Bool
  137.                 Neighbours3 [_,_,_]    = True
  138.                 Neighbours3 _         = False    
  139.             NewBorns1 [] newbornsnext gennext _
  140.             =    (gennext,newbornsnext)
  141.             
  142.             //    NewBornNeighbours c gen -> dead neighbours of c in gen in decreasing order.
  143.             
  144.             NewBornNeighbours::!LifeCell !Generation -> [LifeCell]
  145.             NewBornNeighbours {x,y} gen
  146.             =    NewBornNeighbours1 (x-1) (x+1) (y-1) gen []
  147.             where
  148.                 NewBornNeighbours1:: !Int !Int !Int !Generation ![LifeCell] -> [LifeCell]
  149.                 NewBornNeighbours1 x xn y [cs=:[{x=x2}:_]:cs_xs] newborns
  150.                 |    x>xn        = newborns
  151.                 |    x2<x        = NewBornNeighbours1 x xn y cs_xs newborns
  152.                 |    x2==x        = NewBornNeighbours2 x y (y+2) cs (NewBornNeighbours1 (x+1) xn y cs_xs newborns)
  153.                 |    otherwise    = [NewLifeCell x y,NewLifeCell x (y+1),NewLifeCell x (y+2):NewBornNeighbours1 (x+1) xn y cs_xs newborns]
  154.                 NewBornNeighbours1 x xn y [] newborns
  155.                 |    x>xn        = newborns
  156.                 |    otherwise    = [NewLifeCell x y,NewLifeCell x (y+1),NewLifeCell x (y+2):NewBornNeighbours1 (x+1) xn y [] newborns]
  157.                 
  158.                 NewBornNeighbours2:: !Int !Int !Int ![LifeCell] ![LifeCell] -> [LifeCell]
  159.                 NewBornNeighbours2 x y yn [c=:{x=x2,y=y2}:cs] cs_xs
  160.                 |    y>yn        = cs_xs
  161.                 |    y2<y        = NewBornNeighbours2 x y yn cs cs_xs
  162.                 |    y2==y        = NewBornNeighbours2 x (y+1) yn cs cs_xs
  163.                 |    otherwise    = [NewLifeCell x y:NewBornNeighbours2 x (y+1) yn cs cs_xs]
  164.                 NewBornNeighbours2 x y yn [] cs_xs
  165.                 |    y>yn        = cs_xs
  166.                 |    otherwise    = [NewLifeCell x y:NewBornNeighbours2 x (y+1) yn [] cs_xs]
  167.         
  168.         ShiftGeneration::!Generation !Generation -> Generation
  169.         ShiftGeneration [[c=:{x,y}:_]:_] gen    = ShiftGeneration1 {c & x=x-2,y=y-2} gen
  170.         ShiftGeneration [[],[c=:{x,y}:_]:_] gen    = ShiftGeneration1 {c & x=x-2,y=y-2} gen
  171.         ShiftGeneration partial_gen gen            = gen
  172.         
  173.         ShiftGeneration1::!LifeCell !Generation -> Generation
  174.         ShiftGeneration1 c=:{x=x1,y=y1} gen=:[[c2=:{x=x2,y=y2}:cs_x]:cs_xs]
  175.         |    x2<x1                        = ShiftGeneration1 c cs_xs
  176.         |    x2==x1 && y2<y1                = ShiftGeneration1 c [cs_x:cs_xs]
  177.         |    otherwise                    = gen
  178.         ShiftGeneration1 c [[]:cs_xs]
  179.         =    ShiftGeneration1 c cs_xs
  180.         ShiftGeneration1 c _
  181.         =    []
  182.         
  183.         //    Neighbours c gen -> neighbours of c in gen in decreasing order.
  184.         
  185.         Neighbours::!LifeCell !Generation -> [LifeCell]
  186.         Neighbours {x,y} gen
  187.         =    Neighbours1 (x-1) (x+1) (y-1) gen []
  188.         where
  189.             Neighbours1:: !Int !Int !Int !Generation ![LifeCell] -> [LifeCell]
  190.             Neighbours1 x xn y [cs=:[{x=x2,y=y2}:_]:cs_xs] neighbours
  191.             |    x2<x                        = Neighbours1 x xn y cs_xs neighbours
  192.             |    x2<=xn                        = Neighbours2 y (y+2) cs (Neighbours1 (x+1) xn y cs_xs neighbours)
  193.             |    otherwise                    = neighbours
  194.             Neighbours1 _ _ _ [] neighbours    = neighbours
  195.             
  196.             Neighbours2:: !Int !Int ![LifeCell] ![LifeCell] -> [LifeCell]
  197.             Neighbours2 y yn [c=:{x=x2,y=y2}:cs] cs_xs
  198.             |    y2<y                        = Neighbours2 y yn cs cs_xs
  199.             |    y2<=yn                        = [c:Neighbours2 (y+1) yn cs cs_xs]
  200.             |    otherwise                    = cs_xs
  201.             Neighbours2 _ _ [] cs_xs        = cs_xs
  202.     NextGen [[]:cs_xs] gen
  203.     =    NextGen cs_xs gen
  204.     NextGen _ _
  205.     =    ([],[],[])
  206.     
  207.     CelebrateSurvival :: !Generation !Generation -> Generation
  208.     CelebrateSurvival new old
  209.     =    map (map (celebrate old)) new
  210.     where
  211.         celebrate :: !Generation !LifeCell -> LifeCell
  212.         celebrate old newcell
  213.         |    found        = {newcell & age=age+1}
  214.                         = {newcell & age=age}
  215.         where
  216.             (found,age)    = GetCellAge newcell old
  217.         
  218.         GetCellAge :: !LifeCell !Generation -> (!Bool,!Int)
  219.         GetCellAge c1=:{x=x1} [xs=:[{x=x2}:_]:xss]
  220.         |    x1<x2        = (False,0)
  221.         |    x1>x2        = GetCellAge  c1 xss
  222.         |    otherwise    = GetCellAge` c1 xs
  223.         GetCellAge _ _    = (False,0)
  224.         
  225.         GetCellAge` :: !LifeCell ![LifeCell] -> (!Bool,!Int)
  226.         GetCellAge` c1=:{y=y1} [{y=y2,age}:xs]
  227.         |    y1<y2        = (False,0)
  228.         |    y1>y2        = GetCellAge` c1 xs
  229.         |    otherwise    = (True,age)
  230.         GetCellAge` _ _    = (False,0)
  231.